home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / MEMBER < prev    next >
Encoding:
Text File  |  1992-01-22  |  4.4 KB  |  151 lines
  1. \ This files supports the definition of structure members
  2. \ similar to those used in 'C'.  This file, along with JU:C_STRUCT
  3. \ are used to access the Amiga internal data structures.
  4. \
  5. \ Some of this same code is also used by ODE,
  6. \ the Object Development Environment.
  7. \
  8. \ Author: Phil Burk
  9. \ Copyright 1986 Phil Burk
  10. \
  11. \ MOD: PLB 1/16/87 Use abort" instead of er.report.
  12. \ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal.
  13. \ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs.
  14. \ MOD: PLB 7/31/88 Add USHORT and UBYTE.
  15. \ MOD: PLB 1/20/89 Treat LITERAL as state sensitive.
  16. \ MOD: PLB 2/23/90 Allow triple unions. Make APTR use -4.
  17. \ MOD: PLB 7/9/91 recoverd from old disk, c/ju:/jf:/
  18. \ 00001 mdh 22-oct-91 implement 0 error in ob.findit
  19. \ 00002 PLB 1/22/92 Use $ERROR instead of 0 ERROR.
  20.  
  21. INCLUDE? HO.FIND.PFA JF:AJF_DICT
  22.  
  23. ANEW TASK-MEMBER
  24. decimal
  25.  
  26. \ Variables shared with object oriented code.
  27. .NEED OB-STATE
  28.     VARIABLE OB-STATE  ( Compilation state. )
  29.     VARIABLE OB-CURRENT-CLASS  ( ABS_CLASS_BASE of current class )
  30.     1 constant OB_DEF_CLASS   ( defining a class )
  31.     2 constant OB_DEF_STRUCT  ( defining a structure )
  32. .THEN
  33.  
  34. 4 constant OB_OFFSET_SIZE
  35.  
  36. ob_offset_size 4 =
  37. .IF
  38.     : OB.OFFSET@ ( member_def -- offset ) @ ;
  39.     : OB.OFFSET, ( value -- ) , ;
  40.     : OB.SIZE@ ( member_def -- offset )
  41.         ob_offset_size + @ ;
  42.     : OB.SIZE, ( value -- ) , ;
  43. .ELSE
  44.     : OB.OFFSET@ ( member_def -- offset ) w@ ;
  45.     : OB.OFFSET, ( value -- ) w, ;
  46.     : OB.SIZE@ ( member_def -- offset )
  47.          ob_offset_size + w@ w->s ;
  48.     : OB.SIZE, ( value -- ) w, ;
  49. ;
  50. .THEN
  51.  
  52. ( Members are associated with an offset from the base of a structure. )
  53. : OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time)
  54.        dup >r  ( -- +-b , save #bytes )
  55.        ABS     ( -- |+-b| )
  56.        ob-current-class @ ( -- b addr-space)
  57.        tuck @          ( as #b c , current space needed )
  58.        over 2 mod 0=        ( even ammount of data? )
  59.        IF even-up ( make sure words and longs start on even boundary )
  60.        THEN
  61.        swap over + rot !    ( update space needed )
  62. \ Save data in member definition. %M
  63.        ob.offset,    ( save old offset for ivar )
  64.        r> ob.size,   ( store size in bytes for ..! and ..@ )
  65. ;
  66.  
  67. \ Unions allow one to address the same memory as different members.
  68. \ Unions work by saving the current offset for members on
  69. \ the stack and then reusing it for different members.
  70. : UNION{  ( -- old-offset new-offset , Start union definition. )
  71.     ob-current-class @ @ dup
  72. ;
  73.  
  74. : }UNION{ ( old new -- old maxnew , Middle of union )
  75.     ob-current-class @ @ ( get current offset ) MAX
  76.     over ob-current-class @ !  ( Set back to old )
  77. ;
  78.  
  79. : }UNION ( old new -- , Terminate union definition, check lengths. )
  80.     ob-current-class @ @ MAX
  81.     ob-current-class @ !   ( set to largest part of union )
  82.     drop
  83. ;
  84.  
  85. \ Make members compile their offset, for "disposable includes".
  86. : OB.MEMBER  ( #bytes -- , make room in an object at compile time)
  87.            ( -- offset , run time for structure )
  88.     CREATE ob.make.member immediate
  89.     DOES> ob.offset@  ( get offset ) [compile] literal
  90. ;
  91.  
  92. : OB.FINDIT  ( <thing> -- pfa , get pfa of thing or error )
  93.     ho.find.pfa not
  94.     IF
  95.        " OB.FINDIT - Word not found!" $error \ 00002
  96.     THEN
  97. ;
  98.  
  99. : OB.STATS ( member_pfa --  offset #bytes )
  100.     dup ob.offset@ swap
  101.     ob.size@
  102. ;
  103.  
  104. : OB.STATS? ( <member> -- offset #bytes )
  105.     ob.findit ob.stats
  106. ;
  107.  
  108. : SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )
  109.     ob.findit @
  110.     [compile] literal
  111. ; immediate
  112.  
  113. \ Basic word for defining structure members.
  114. : BYTES ( #bytes -- , error check for structure only )
  115.     ob-state @ ob_def_struct = not
  116.     IF " BYTES - Only valid in :STRUCT definitions." $ERROR
  117.     THEN
  118.     ob.member
  119. ;
  120.  
  121. \ Declare various types of structure members.
  122. \ Negative size indicates a signed member.
  123. : BYTE ( <name> -- , declare space for a byte )
  124.     -1 bytes ;
  125.  
  126. : SHORT ( <name> -- , declare space for a 16 bit value )
  127.     -2 bytes ;
  128.  
  129. : LONG ( <name> -- )
  130.     cell bytes ;
  131.  
  132. : RPTR ( <name> -- , relative address pointer )
  133.     cell bytes ;
  134.  
  135. : APTR    ( <name> -- , store as -4 for auto >ABS >REL )
  136.     cell negate bytes ;
  137.  
  138. : UBYTE ( <name> -- , declare space for signed  byte )
  139.     1 bytes ;
  140.  
  141. : USHORT ( <name> -- , declare space for signed 16 bit value )
  142.     2 bytes ;
  143.  
  144.  
  145. \ Aliases
  146. : ULONG   ( <name> -- ) long ;
  147.  
  148. : STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )
  149.     [compile] sizeof() bytes
  150. ;
  151.